Attribute VB_Name = "modBITMAP"
Option Explicit
Private Type BITMAP           '14 bytes
  bmType As Long
  bmWidth As Long
  bmHeight As Long
  bmWidthBytes As Long
  bmPlanes As Long
  bmBitsPixel As Long
  bmBits As Long
End Type

Public Type BITMAPINFOHEADER  '40 bytes
  biSize As Long
  biWidth As Long
  biHeight As Long
  biPlanes As Integer
  biBitCount As Integer
  biCompression As Long
  biSizeImage As Long
  biXPelsPerMeter As Long
  biYPelsPerMeter As Long
  biClrUsed As Long
  biClrImportant As Long
End Type

Public Type RGBQUAD           '4 bytes
  rgbBlue As Byte
  rgbGreen As Byte
  rgbRed As Byte
  rgbReserved As Byte
End Type

Public base As GLuint         ' Base Display List For The Font Set
Public mloop As GLuint          ' Generic Loop Variable

Public cnt1 As GLfloat            ' 1st Counter Used To Move Text & For Coloring
Public cnt2 As GLfloat

Public Function LoadBITMAP(strname As String) As Byte()
Dim sFile As String
Dim bmFile As BITMAPFILEHEADER
Dim bmInfo As BITMAPINFOHEADER
Dim bmRGB() As RGBQUAD
Dim iFile As Integer
Dim lImageSize As Long
Dim iPixelSize As Integer
Dim baImageData() As Byte

  On Error GoTo err_h

  'Set the filename
  sFile = App.Path & "\" & strname
  
  iFile = FreeFile
  
  Open sFile For Binary As iFile
  
  'Read in the headers
  Get #iFile, , bmFile
  Get #iFile, , bmInfo
  
  'Determine how many colors are used
  If (bmInfo.biBitCount < 24) Then
    'Less than 24 bits per pixel are used, so allocate space for the color table
    ReDim bmRGB(bmInfo.biClrUsed)
    
    'Read in the color table
    Get #iFile, , bmRGB
  End If
  
  'Determine how big the image is
  iPixelSize = bmInfo.biBitCount / 8
  
  lImageSize = bmInfo.biWidth * bmInfo.biHeight * iPixelSize
  
  ReDim baImageData(lImageSize)
  
  'Read in the image data
  Get #iFile, , baImageData
  
  Close #iFile
  LoadBITMAP = baImageData
Exit Function
err_h:
MsgBox "error loading bitmap data"
End Function

Public Function LoadGLTextures() As Boolean
' Load Bitmaps And Convert To Textures
    Dim Status As Boolean
    Dim h1 As Long
    Dim w1 As Long

    Dim TextureImage1() As GLbyte

    Status = False                         ' Status Indicator

    If LoadBMP("Data\Font.BMP", TextureImage1(), h1, w1) Then
       
            ' Load The Bitmap, Check For Errors, If Bitmap's Not Found Quit
            Status = True                          ' Set The Status To TRUE
    
            glGenTextures 1, Texture(0)            ' Create The Textures

            ' Build All The Textures
            glBindTexture glTexture2D, Texture(0)
            glTexParameteri glTexture2D, tpnTextureMagFilter, GL_LINEAR
            glTexParameteri glTexture2D, tpnTextureMinFilter, GL_LINEAR
            glTexImage2D glTexture2D, 0, 3, w1, h1, 0, GL_RGB, GL_UNSIGNED_BYTE, TextureImage1(0, 0, 0)
    
          
   Else
   MsgBox "errore caricamento fontr"
   End If

    Erase TextureImage1   ' Free the texture image memory    Erase TextureImage2   ' Free the texture image memory
    
    LoadGLTextures = Status
End Function
Private Sub CreateTextureMapFromImage(pict As PictureBox, ByRef TextureImg() As GLbyte, ByRef Height As Long, ByRef width As Long)
    ' Create the array as needed for the image.
    pict.ScaleMode = 3                  ' Pixels
    Height = pict.ScaleHeight
    width = pict.ScaleWidth
    
    ReDim TextureImg(2, Height - 1, width - 1)
    
    ' Fill the array with the bitmap data...  This could take
    ' a while...
    
    Dim x As Long, y As Long
    Dim c As Long
    
    Dim yloc As Long
    For x = 0 To width - 1
        For y = 0 To Height - 1
            c = pict.Point(x, y)                ' Returns in long format.
            yloc = Height - y - 1
            TextureImg(0, x, yloc) = c And 255
            TextureImg(1, x, yloc) = (c And 65280) \ 256
            TextureImg(2, x, yloc) = (c And 16711680) \ 65536
        Next y
    Next x
    
End Sub

Private Function LoadBMP(ByVal Filename As String, ByRef Textured() As GLuint, ByRef Height As Long, ByRef width As Long) As Boolean

    Dim intFileHandle As Integer
    Dim bitmapheight As Long
    Dim bitmapwidth As Long

    ' Open a file.
    ' The file should be BMP with pictures 64x64,128x128,256x256 .....
  
    If Filename = "" Then
        End
    End If
    If UCase(Right(Filename, 3)) = "BMP" Then
       fmain.Picture1.Picture = LoadPicture(Filename)
        CreateTextureMapFromImage fmain.Picture1, Textured(), Height, width
    End If
    LoadBMP = True
End Function


Public Sub glPrint(x As GLint, y As GLint, s As String, sset As Integer)
' Where The Printing Happens
    If (sset > 1) Then                            ' Is set Greater Than One?
        sset = 1                            ' If So, Make Set Equal One
    End If
    glEnable glcBlend
    glEnable glcTexture2D
    glBindTexture GL_TEXTURE_2D, Texture(0)               ' Select Our Font Texture

    glDisable glcDepthTest ' Disables Depth Testing
    
 
    glMatrixMode GL_PROJECTION                        ' Select The Projection Matrix
    glPushMatrix                             ' Store The Projection Matrix

    glLoadIdentity                           ' Reset The Projection Matrix
    glOrtho 0, 800, 0, 600, -1, 1                     ' Set Up An Ortho Screen

    glMatrixMode GL_MODELVIEW                     ' Select The Modelview Matrix
    glPushMatrix                             ' Store The Modelview Matrix
    glLoadIdentity                           ' Reset The Modelview Matrix

    glTranslated x, y, 0                          ' Position The Text (0,0 - Bottom Left)

    glListBase base - 32 + 128 * sset                ' Choose The Font Set (0 or 1)

    Dim b() As Byte
    Dim i As Integer
    Dim length As Double
    ReDim b(Len(s))             ' array of bytes to hold the string
    For i = 1 To Len(s)         ' for each character
        b(i - 1) = Asc(Mid$(s, i, 1)) ' convert from unicode to ascii
    Next
    b(Len(s)) = 0               ' null terminated
    glCallLists Len(s), GL_BYTE, b(0)            ' Write The Text To The Screen

    glMatrixMode GL_PROJECTION                        ' Select The Projection Matrix
    glPopMatrix                              ' Restore The Old Projection Matrix

    glMatrixMode GL_MODELVIEW                     ' Select The Modelview Matrix
    glPopMatrix                              ' Restore The Old Projection Matrix

    glEnable glcDepthTest ' Enables Depth Testing
    glDisable glcTexture2D
    glDisable glcBlend
End Sub

Private Sub KillFont()                     ' Delete The Font
    glDeleteLists base, 256                ' Delete All 256 Characters
End Sub
Public Sub BuildFont()                  '
    Dim cx As Double                             ' Holds Our X Character Coord
    Dim cy As Double                             ' Holds Our Y Character Coord
    Dim i As Integer
    base = glGenLists(256)                         ' Creating 256 Display Lists
    glBindTexture glTexture2D, Texture(0)                ' Select Our Font Texture

    For i = 0 To 255                      ' Loop Through All 256 Lists
  
        cx = (i Mod 16) / 16#                   ' X Position Of Current Character
        ' note the integer divide below
        cy = (i \ 16) / 16#                ' Y Position Of Current Character

        glNewList base + i, lstCompile              ' Start Building A List

            glBegin bmQuads                   ' Use A Quad For Each Character

                glTexCoord2f cx, 1 - cy - 0.0625      ' Texture Coord (Bottom Left)
                glVertex2i 0, 0               ' Vertex Coord (Bottom Left)

                glTexCoord2f cx + 0.0625, 1 - cy - 0.0625 ' Texture Coord (Bottom Right)
                glVertex2i 16, 0             ' Vertex Coord (Bottom Right)

                glTexCoord2f cx + 0.0625, 1 - cy      ' Texture Coord (Top Right)
                glVertex2i 16, 16             ' Vertex Coord (Top Right)

                glTexCoord2f cx, 1 - cy           ' Texture Coord (Top Left)
                glVertex2i 0, 16              ' Vertex Coord (Top Left)
            glEnd                        ' Done Building Our Quad (Character)

            glTranslated 10, 0, 0                 ' Move To The Right Of The Character
        glEndList                            ' Done Building The Display List
    Next i                                   ' Loop Until All 256 Are Built

End Sub

